home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / str-class.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-29  |  15.1 KB  |  344 lines
  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defmethod initialize-internal-slot-functions :after
  31.           ((slotd structure-effective-slot-definition))
  32.   (let ((name (slot-definition-name slotd)))
  33.     (initialize-internal-slot-reader-gfs name)
  34.     (initialize-internal-slot-writer-gfs name)
  35.     (initialize-internal-slot-boundp-gfs name)))
  36.  
  37. (defmethod slot-definition-allocation ((slotd structure-slot-definition))
  38.   :instance)
  39.  
  40. (defmethod class-prototype ((class structure-class))
  41.   (with-slots (prototype) class
  42.     (or prototype
  43.         (setq prototype (make-class-prototype class)))))
  44.  
  45. (defmethod make-class-prototype ((class structure-class))
  46.   (with-slots (wrapper defstruct-constructor) class
  47.     (if defstruct-constructor
  48.         (make-instance class)
  49.       (let* ((proto (%allocate-instance--class *empty-vector*)))
  50.          (shared-initialize proto T :check-initargs-legality-p NIL)
  51.          (setf (std-instance-wrapper proto) wrapper)
  52.          proto))))
  53.  
  54.  
  55. (defmethod make-direct-slotd ((class structure-class)
  56.                               &rest initargs
  57.                               &key
  58.                               (name (error "Slot needs a name."))
  59.                               (conc-name (class-defstruct-conc-name class))
  60.                               (defstruct-accessor-symbol () acc-sym-p)
  61.                               &allow-other-keys)
  62.   (declare (ignore defstruct-accessor-symbol))
  63.   (declare (type symbol        name)
  64.            (type simple-string conc-name))
  65.   (let ((initargs (list* :class class :allow-other-keys T initargs)))
  66.     (unless acc-sym-p
  67.       (setf initargs
  68.             (list* :defstruct-accessor-symbol
  69.                    (intern (concatenate 'simple-string conc-name (symbol-name name))
  70.                            (symbol-package (class-name class)))
  71.                    initargs)))
  72.     (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
  73.  
  74. (defun slot-definition-defstruct-slot-description (slot)
  75.   (let ((type (slot-definition-type slot)))
  76.     `(,(slot-definition-name slot) ,(slot-definition-initform slot)
  77.       ,@(unless (eq type t) `(:type ,type)))))
  78.  
  79. (defmethod shared-initialize :after 
  80.       ((class structure-class)
  81.        slot-names
  82.        &key (direct-superclasses nil direct-superclasses-p)
  83.             (direct-slots nil direct-slots-p)
  84.             direct-default-initargs
  85.             (predicate-name   nil predicate-name-p))
  86.   (declare (ignore slot-names direct-default-initargs))
  87.   (let* ((name (class-name class))
  88.          (from-defclass-p (slot-value class 'from-defclass-p))
  89.          (defstruct-form (defstruct-form name))
  90.          (conc-name
  91.            (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
  92.                (slot-value class 'defstruct-conc-name)
  93.                (format nil #-excl "~s structure class "
  94.                            #+excl "~s_STRUCTURE.CLASS_"
  95.                            name)))
  96.          (defstruct-predicate
  97.            (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
  98.          (pred-name  ;; Predicate name for class
  99.            (or (if predicate-name-p (car predicate-name))
  100.                (if defstruct-form defstruct-predicate)
  101.                (slot-value class 'predicate-name)
  102.                (make-class-predicate-name name)))
  103.          (constructor
  104.            (or (if defstruct-form (defstruct-form-constructor defstruct-form))
  105.                (slot-value class 'defstruct-constructor)
  106.                (if from-defclass-p
  107.                    (list (intern (format nil "~aconstructor" conc-name)
  108.                                  (symbol-package name))
  109.                          ())))))
  110.     (declare (type symbol        name defstruct-predicate pred-name)
  111.              (type boolean       from-defclass-p)
  112.              (type simple-string conc-name))
  113.     (if direct-superclasses-p
  114.         (setf (slot-value class 'direct-superclasses)
  115.           (or direct-superclasses
  116.           (setq direct-superclasses
  117.                         (if (eq name 'structure-object)
  118.                             nil
  119.                 (list *the-class-structure-object*)))))
  120.         (setq direct-superclasses (slot-value class 'direct-superclasses)))
  121.     (setq direct-slots
  122.           (if direct-slots-p
  123.           (setf (slot-value class 'direct-slots)
  124.             (mapcar #'(lambda (pl)
  125.                                 (apply #'make-direct-slotd class
  126.                                         :conc-name conc-name pl))
  127.                 direct-slots))
  128.           (slot-value class 'direct-slots)))
  129.     (when from-defclass-p
  130.       (do-defstruct-from-defclass
  131.         class direct-superclasses direct-slots conc-name pred-name constructor))
  132.     (compile-structure-class-internals
  133.         class direct-slots conc-name pred-name constructor)
  134.     (setf (slot-value class 'predicate-name) pred-name)
  135.     (setf (slot-value class 'defstruct-conc-name) conc-name)
  136.     (unless (extract-required-parameters (second constructor))
  137.       (setf (slot-value class 'defstruct-constructor) (car constructor)))
  138.     (when (and defstruct-predicate (not from-defclass-p))
  139.       (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
  140.     (unless (or from-defclass-p (slot-value class 'documentation))
  141.       (setf (slot-value class 'documentation)
  142.             (format nil "~S structure class made from Defstruct" name)))
  143.     (setf (find-class name) class)
  144.     (update-structure-class class direct-superclasses direct-slots)))
  145.  
  146. (defun update-structure-class (class direct-superclasses direct-slots)
  147.   (add-direct-subclasses class direct-superclasses)
  148.   (let ((cpl (compute-class-precedence-list class)))
  149.     (setf (slot-value class 'class-precedence-list) cpl)
  150.     (let* ((eslotds (compute-slots class))
  151.            (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
  152.       (setf (slot-value class 'slots) eslotds)
  153.       (setf (slot-value class 'internal-slotds) internal-slotds)
  154.       (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
  155.     (if (slot-value class 'wrapper)
  156.         (setf (wrapper-class-precedence-list (slot-value class 'wrapper)) cpl)
  157.         (progn
  158.           (setf (slot-value class 'finalized-p) T)
  159.           (setf (slot-value class 'wrapper) (make-wrapper class))))
  160.     (unless (slot-boundp class 'prototype)
  161.       (setf (slot-value class 'prototype) nil))
  162.     (setf (slot-value class 'default-initargs) nil))
  163.   (add-slot-accessors class direct-slots))
  164.  
  165. (defmethod do-defstruct-from-defclass ((class structure-class)
  166.                                        direct-superclasses direct-slots
  167.                                        conc-name predicate constructor)
  168.   (declare (type simple-string conc-name))
  169.   (let* ((name (class-name class))
  170.          (original-defstruct-form
  171.           `(original-defstruct
  172.               (,name
  173.          ,@(when direct-superclasses
  174.            `((:include ,(class-name (car direct-superclasses)))))
  175.          (:print-function print-std-instance)
  176.          (:predicate ,predicate)
  177.          (:conc-name ,(intern conc-name (symbol-package name)))
  178.          (:constructor ,@constructor))
  179.             ,@(mapcar #'slot-definition-defstruct-slot-description
  180.                       direct-slots))))
  181.     (eval original-defstruct-form)
  182.     (store-defstruct-form (cdr original-defstruct-form))))
  183.  
  184. (defmethod compile-structure-class-internals ((class structure-class)
  185.                                               direct-slots conc-name
  186.                                               predicate-name constructor)
  187.   (declare (type simple-string conc-name))
  188.   (let* ((name    (class-name class))
  189.          (package (symbol-package name))
  190.          (direct-slots-needing-internals
  191.            (if (slot-value class 'from-defclass-p)
  192.                direct-slots
  193.                (remove-if #'slot-definition-internal-reader-function
  194.                           direct-slots)))
  195.      (reader-names
  196.            (mapcar #'(lambda (slotd)
  197.                (intern (format nil "~A~A reader" conc-name
  198.                        (slot-definition-name slotd))
  199.                                 package))
  200.            direct-slots-needing-internals))
  201.      (writer-names
  202.            (mapcar #'(lambda (slotd)
  203.                (intern (format nil "~A~A writer" conc-name 
  204.                        (slot-definition-name slotd))
  205.                                package))
  206.            direct-slots-needing-internals))
  207.          (defstruct-accessor-names
  208.            (mapcar #'slot-definition-defstruct-accessor-symbol
  209.                    direct-slots-needing-internals))
  210.      (readers-init
  211.        (mapcar #'(lambda (defstruct-accessor reader-name)
  212.                `(progn
  213.                           (force-compile ',defstruct-accessor)
  214.                           (defun ,reader-name (obj)
  215.                     (declare (type ,name obj) #.*optimize-speed*)
  216.                 (,defstruct-accessor obj))
  217.                           (force-compile ',reader-name)))
  218.            defstruct-accessor-names reader-names))
  219.      (writers-init
  220.        (mapcar #'(lambda (defstruct-accessor writer-name)
  221.                `(progn
  222.                           (force-compile ',defstruct-accessor)
  223.                           (defun ,writer-name (nv obj)
  224.                 (declare (type ,name obj) #.*optimize-speed*)
  225.                 (setf (,defstruct-accessor obj) nv))
  226.                           (force-compile ',writer-name)))
  227.            defstruct-accessor-names writer-names))
  228.      (defstruct-extras-form
  229.        `(progn
  230.               ,@(when (car constructor)
  231.                   `((force-compile ',(car constructor))))
  232.               ,@(when (fboundp predicate-name)
  233.                   `((force-compile ',predicate-name)))
  234.           ,@readers-init
  235.               ,@writers-init)))
  236.     (declare (type package package))
  237.     (eval defstruct-extras-form)
  238.     (mapc #'(lambda (dslotd reader-name writer-name)
  239.           (setf (slot-value dslotd 'internal-reader-function)
  240.                     (gdefinition reader-name))
  241.           (setf (slot-value dslotd 'internal-writer-function)
  242.                     (gdefinition writer-name)))
  243.       direct-slots-needing-internals reader-names writer-names)))
  244.  
  245. (defmethod reinitialize-instance :after ((class structure-class)
  246.                      &rest initargs
  247.                      &key)
  248.   (map-dependents class
  249.           #'(lambda (dependent)
  250.               (apply #'update-dependent class dependent initargs))))
  251.  
  252. (defmethod direct-slot-definition-class ((class structure-class) initargs)
  253.   (declare (ignore initargs))
  254.   (find-class 'structure-direct-slot-definition))
  255.  
  256. (defmethod effective-slot-definition-class ((class structure-class) initargs)
  257.   (declare (ignore initargs))
  258.   (find-class 'structure-effective-slot-definition))
  259.  
  260. (defmethod finalize-inheritance ((class structure-class))
  261.   nil) ; always finalized
  262.  
  263.  
  264. (defmethod compute-slots ((class structure-class))
  265.   (mapcan #'(lambda (superclass)
  266.           (mapcar #'(lambda (dslotd)
  267.               (compute-effective-slot-definition
  268.                  class (slot-definition-name dslotd) (list dslotd)))
  269.               (class-direct-slots superclass)))
  270.       (reverse (slot-value class 'class-precedence-list))))
  271.  
  272. (defmethod compute-slots :around ((class structure-class))
  273.   (let ((eslotds (call-next-method)))
  274.     (mapc #'initialize-internal-slot-functions eslotds)
  275.     eslotds))
  276.  
  277. (defmethod compute-effective-slot-definition ((class structure-class)
  278.                                               name dslotds)
  279.   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
  280.      (class (effective-slot-definition-class class initargs))
  281.          (slot-definition (apply #'make-instance class initargs))
  282.          (internal-slotd
  283.            (make-internal-slotd
  284.              :name name
  285.              :slot-definition slot-definition
  286.              :initargs        (slot-definition-initargs     slot-definition)
  287.              :initfunction    (slot-definition-initfunction slot-definition))))
  288.     (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
  289.     slot-definition))
  290.  
  291. (defmethod compute-effective-slot-definition-initargs :around
  292.     ((class structure-class) direct-slotds)
  293.   (let ((slotd (car direct-slotds)))
  294.     (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
  295.        :internal-reader-function (slot-definition-internal-reader-function slotd)
  296.        :internal-writer-function (slot-definition-internal-writer-function slotd)
  297.        (call-next-method))))
  298.  
  299.  
  300. (defmethod make-optimized-reader-method-function ((class structure-class)
  301.                                                   generic-function
  302.                                                   reader-method-prototype
  303.                                                   slot-name)
  304.   (declare (ignore generic-function reader-method-prototype))
  305.   (make-structure-instance-reader-method-function slot-name))
  306.  
  307. (defmethod make-optimized-writer-method-function ((class structure-class)
  308.                                                   generic-function
  309.                                                   writer-method-prototype
  310.                                                   slot-name)
  311.   (declare (ignore generic-function writer-method-prototype))
  312.   (make-structure-instance-writer-method-function slot-name))
  313.  
  314. (defmethod make-optimized-boundp-method-function ((class structure-class)
  315.                                                   generic-function
  316.                                                   boundp-method-prototype
  317.                                                   slot-name)
  318.   (declare (ignore generic-function boundp-method-prototype))
  319.   (make-structure-instance-boundp-method-function slot-name))
  320.  
  321.  
  322. (defun make-structure-instance-reader-method-function (slot-name)
  323.   (declare #.*optimize-speed*)
  324.   #'(lambda (instance)
  325.       (structure-instance-slot-value instance slot-name)))
  326.  
  327. (defun make-structure-instance-writer-method-function (slot-name)
  328.   (declare #.*optimize-speed*)
  329.   #'(lambda (nv instance)
  330.       (setf (structure-instance-slot-value instance slot-name) nv)))
  331.  
  332. (defun make-structure-instance-boundp-method-function (slot-name)
  333.   (declare #.*optimize-speed*)
  334.   #'(lambda (instance)
  335.       (structure-instance-slot-boundp instance slot-name)))
  336.  
  337. (defmethod wrapper-fetcher ((class structure-class))
  338.   'wrapper-for-structure)
  339.  
  340. (defmethod slots-fetcher ((class structure-class))
  341.   NIL)
  342.  
  343.  
  344.